home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / os2 / octa209s.zip / octave-2.09 / src / pt-fcn.cc < prev    next >
C/C++ Source or Header  |  1997-05-26  |  12KB  |  555 lines
  1. /*
  2.  
  3. Copyright (C) 1996 John W. Eaton
  4.  
  5. This file is part of Octave.
  6.  
  7. Octave is free software; you can redistribute it and/or modify it
  8. under the terms of the GNU General Public License as published by the
  9. Free Software Foundation; either version 2, or (at your option) any
  10. later version.
  11.  
  12. Octave is distributed in the hope that it will be useful, but WITHOUT
  13. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15. for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with Octave; see the file COPYING.  If not, write to the Free
  19. Software Foundation, 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
  20.  
  21. */
  22.  
  23. #if defined (__GNUG__)
  24. #pragma implementation
  25. #endif
  26.  
  27. #ifdef HAVE_CONFIG_H
  28. #include <config.h>
  29. #endif
  30.  
  31. #include <iostream.h>
  32.  
  33. #include <defaults.h>
  34. #include "defun.h"
  35. #include "error.h"
  36. #include "gripes.h"
  37. #include "help.h"
  38. #include "input.h"
  39. #include "pager.h"
  40. #include "symtab.h"
  41. #include "toplev.h"
  42. #include "pt-exp.h"
  43. #include "pt-fcn.h"
  44. #include "pt-misc.h"
  45. #include "pt-pr-code.h"
  46. #include "pt-walk.h"
  47. #include "unwind-prot.h"
  48. #include "utils.h"
  49. #include "ov.h"
  50. #include "variables.h"
  51.  
  52. // If TRUE, variables returned from functions have default values even
  53. // if they are not explicitly initialized.
  54. static bool Vdefine_all_return_values;
  55.  
  56. // If TRUE, the last computed value is returned from functions that
  57. // don't actually define any return variables.
  58. static bool Vreturn_last_computed_value;
  59.  
  60. // If TRUE, turn off printing of results in functions (as if a
  61. // semicolon has been appended to each statement).
  62. static bool Vsilent_functions;
  63.  
  64. // Nonzero means we're breaking out of a loop or function body.
  65. extern int breaking;
  66.  
  67. // Nonzero means we're returning from a function.
  68. extern int returning;
  69.  
  70. // User defined functions.
  71.  
  72. void
  73. tree_function::install_nargin_and_nargout (void)
  74. {
  75.   nargin_sr = sym_tab->lookup ("nargin", 1, 0);
  76.   nargout_sr = sym_tab->lookup ("nargout", 1, 0);
  77. }
  78.  
  79. void
  80. tree_function::bind_nargin_and_nargout (int nargin, int nargout)
  81. {
  82.   nargin_sr->define ((double) nargin);
  83.   nargout_sr->define ((double) nargout);
  84. }
  85.  
  86. tree_function::~tree_function (void)
  87. {
  88.   delete param_list;
  89.   delete ret_list;
  90.   delete sym_tab;
  91.   delete cmd_list;
  92.   delete vr_list;
  93. }
  94.  
  95. tree_function *
  96. tree_function::define_param_list (tree_parameter_list *t)
  97. {
  98.   param_list = t;
  99.  
  100.   if (param_list)
  101.     {
  102.       num_named_args = param_list->length ();
  103.       curr_va_arg_number = num_named_args;
  104.     }
  105.  
  106.   return this;
  107. }
  108.  
  109. tree_function *
  110. tree_function::define_ret_list (tree_parameter_list *t)
  111. {
  112.   ret_list = t;
  113.  
  114.   if (ret_list && ret_list->takes_varargs ())
  115.     vr_list = new tree_va_return_list;
  116.  
  117.   return this;
  118. }
  119.  
  120. void
  121. tree_function::stash_fcn_file_name (void)
  122. {
  123.   if (fcn_name.empty ())
  124.     file_name = "";
  125.   else
  126.     file_name = fcn_file_in_path (fcn_name);
  127. }
  128.  
  129. void
  130. tree_function::mark_as_system_fcn_file (void)
  131. {
  132.   if (! file_name.empty ())
  133.     {
  134.       // We really should stash the whole path to the file we found,
  135.       // when we looked it up, to avoid possible race conditions...
  136.       // XXX FIXME XXX
  137.       //
  138.       // We probably also don't need to get the library directory
  139.       // every time, but since this function is only called when the
  140.       // function file is parsed, it probably doesn't matter that
  141.       // much.
  142.  
  143.       string ff_name = fcn_file_in_path (file_name);
  144.  
  145.       if (Vfcn_file_dir.compare (ff_name, 0, Vfcn_file_dir.length ()) == 0)
  146.     system_fcn_file = 1;
  147.     }
  148.   else
  149.     system_fcn_file = 0;
  150. }
  151.  
  152. bool
  153. tree_function::takes_varargs (void) const
  154. {
  155.   return (param_list && param_list->takes_varargs ());
  156. }
  157.  
  158. octave_value
  159. tree_function::octave_va_arg (void)
  160. {
  161.   octave_value retval;
  162.  
  163.   if (curr_va_arg_number < num_args_passed)
  164.     retval = args_passed (curr_va_arg_number++);
  165.   else
  166.     ::error ("va_arg: error getting arg number %d -- only %d provided",
  167.          curr_va_arg_number + 1, num_args_passed);
  168.  
  169.   return retval;
  170. }
  171.  
  172. octave_value_list
  173. tree_function::octave_all_va_args (void)
  174. {
  175.   octave_value_list retval;
  176.  
  177.   retval.resize (num_args_passed - num_named_args);
  178.  
  179.   int k = 0;
  180.   for (int i = num_named_args; i < num_args_passed; i++)
  181.     retval(k++) = args_passed(i);
  182.  
  183.   return retval;
  184. }
  185.  
  186. bool
  187. tree_function::takes_var_return (void) const
  188. {
  189.   return (ret_list && ret_list->takes_varargs ());
  190. }
  191.  
  192. void
  193. tree_function::octave_vr_val (const octave_value& val)
  194. {
  195.   assert (vr_list);
  196.  
  197.   vr_list->append (val);
  198. }
  199.  
  200. void
  201. tree_function::stash_function_name (const string& s)
  202. {
  203.   fcn_name = s;
  204. }
  205.  
  206. octave_value
  207. tree_function::eval (bool print)
  208. {
  209.   octave_value retval;
  210.  
  211.   if (error_state || ! cmd_list)
  212.     return retval;
  213.  
  214.   octave_value_list tmp_args;
  215.   octave_value_list tmp = eval (print, 0, tmp_args);
  216.  
  217.   if (! error_state && tmp.length () > 0)
  218.     retval = tmp(0);
  219.  
  220.   return retval;
  221. }
  222.  
  223. // For unwind protect.
  224.  
  225. static void
  226. pop_symbol_table_context (void *table)
  227. {
  228.   symbol_table *tmp = (symbol_table *) table;
  229.   tmp->pop_context ();
  230. }
  231.  
  232. static void
  233. delete_vr_list (void *list)
  234. {
  235.   tree_va_return_list *tmp = (tree_va_return_list *) list;
  236.   tmp->clear ();
  237.   delete tmp;
  238. }
  239.  
  240. static void
  241. clear_symbol_table (void *table)
  242. {
  243.   symbol_table *tmp = (symbol_table *) table;
  244.   tmp->clear ();
  245. }
  246.  
  247. octave_value_list
  248. tree_function::eval (bool /* print */, int nargout, const octave_value_list& args)
  249. {
  250.   octave_value_list retval;
  251.  
  252.   if (error_state)
  253.     return retval;
  254.  
  255.   if (! cmd_list)
  256.     return retval;
  257.  
  258.   int nargin = args.length ();
  259.  
  260.   begin_unwind_frame ("func_eval");
  261.  
  262.   unwind_protect_int (call_depth);
  263.   call_depth++;
  264.  
  265.   if (call_depth > 1)
  266.     {
  267.       sym_tab->push_context ();
  268.       add_unwind_protect (pop_symbol_table_context, (void *) sym_tab);
  269.  
  270.       if (vr_list)
  271.     {
  272.       // Push new vr_list.
  273.  
  274.       unwind_protect_ptr (vr_list);
  275.       vr_list = new tree_va_return_list;
  276.  
  277.       // Clear and delete the new one before restoring the old
  278.       // one.
  279.  
  280.       add_unwind_protect (delete_vr_list, (void *) vr_list);
  281.     }
  282.     }
  283.  
  284.   if (vr_list)
  285.     vr_list->clear ();
  286.  
  287.   // Force symbols to be undefined again when this function exits.
  288.  
  289.   add_unwind_protect (clear_symbol_table, (void *) sym_tab);
  290.  
  291.   // Save old and set current symbol table context, for
  292.   // eval_undefined_error().
  293.  
  294.   unwind_protect_ptr (curr_sym_tab);
  295.   curr_sym_tab = sym_tab;
  296.  
  297.   unwind_protect_ptr (curr_function);
  298.   curr_function = this;
  299.  
  300.   // XXX FIXME XXX -- ???
  301.   // unwind_protect_ptr (args_passed);
  302.  
  303.   args_passed = args;
  304.  
  305.   unwind_protect_int (num_args_passed);
  306.   num_args_passed = nargin;
  307.  
  308.   unwind_protect_int (num_named_args);
  309.   unwind_protect_int (curr_va_arg_number);
  310.  
  311.   if (param_list && ! param_list->varargs_only ())
  312.     {
  313.       param_list->define_from_arg_vector (args);
  314.       if (error_state)
  315.     goto abort;
  316.     }
  317.  
  318.   if (ret_list && Vdefine_all_return_values)
  319.     {
  320.       octave_value tmp = builtin_any_variable ("default_return_value");
  321.  
  322.       if (tmp.is_defined ())
  323.     ret_list->initialize_undefined_elements (tmp);
  324.     }
  325.  
  326.   // The following code is in a separate scope to avoid warnings from
  327.   // G++ about `goto abort' crossing the initialization of some
  328.   // variables.
  329.  
  330.   {
  331.     bind_nargin_and_nargout (nargin, nargout);
  332.  
  333.     bool echo_commands = (Vecho_executing_commands & ECHO_FUNCTIONS);
  334.  
  335.     if (echo_commands)
  336.       print_code_function_header ();
  337.  
  338.     // Evaluate the commands that make up the function.
  339.  
  340.     bool pf = ! Vsilent_functions;
  341.     octave_value last_computed_value = cmd_list->eval (pf);
  342.  
  343.     if (echo_commands)
  344.       print_code_function_trailer ();
  345.  
  346.     if (returning)
  347.       returning = 0;
  348.  
  349.     if (breaking)
  350.       breaking--;
  351.  
  352.     if (error_state)
  353.       {
  354.     traceback_error ();
  355.     goto abort;
  356.       }
  357.     
  358.     // Copy return values out.
  359.  
  360.     if (ret_list)
  361.       retval = ret_list->convert_to_const_vector (vr_list);
  362.     else if (Vreturn_last_computed_value)
  363.       retval(0) = last_computed_value;
  364.   }
  365.  
  366.  abort:
  367.   run_unwind_frame ("func_eval");
  368.  
  369.   return retval;
  370. }
  371.  
  372. void
  373. tree_function::traceback_error (void)
  374. {
  375.   if (error_state >= 0)
  376.     error_state = -1;
  377.  
  378.   if (fcn_name.empty ())
  379.     {
  380.       if (file_name.empty ())
  381.     ::error ("called from `?unknown?'");
  382.       else
  383.     ::error ("called from file `%s'", file_name.c_str ());
  384.     }
  385.   else
  386.     {
  387.       if (file_name.empty ())
  388.     ::error ("called from `%s'", fcn_name.c_str ());
  389.       else 
  390.     ::error ("called from `%s' in file `%s'",
  391.          fcn_name.c_str (), file_name.c_str ());
  392.     }
  393. }
  394.  
  395. void
  396. tree_function::print_code_function_header (void)
  397. {
  398.   tree_print_code tpc (octave_stdout, Vps4);
  399.  
  400.   tpc.visit_function_header (*this);
  401. }
  402.  
  403. void
  404. tree_function::print_code_function_trailer (void)
  405. {
  406.   tree_print_code tpc (octave_stdout, Vps4);
  407.  
  408.   tpc.visit_function_trailer (*this);
  409. }
  410.  
  411. void
  412. tree_function::accept (tree_walker& tw)
  413. {
  414.   tw.visit_function (*this);
  415. }
  416.  
  417. DEFUN (va_arg, args, ,
  418.   "va_arg (): return next argument in a function that takes a\n\
  419. variable number of parameters")
  420. {
  421.   octave_value_list retval;
  422.  
  423.   int nargin = args.length ();
  424.  
  425.   if (nargin == 0)
  426.     {
  427.       if (curr_function)
  428.     {
  429.       if (curr_function->takes_varargs ())
  430.         retval = curr_function->octave_va_arg ();
  431.       else
  432.         {
  433.           ::error ("va_arg only valid within function taking variable");
  434.           ::error ("number of arguments");
  435.         }
  436.     }
  437.       else
  438.     ::error ("va_arg only valid within function body");
  439.     }
  440.   else
  441.     print_usage ("va_arg");
  442.  
  443.   return retval;
  444. }
  445.  
  446. DEFUN (va_start, args, ,
  447.   "va_start (): reset the pointer to the list of optional arguments\n\
  448. to the beginning")
  449. {
  450.   octave_value_list retval;
  451.  
  452.   int nargin = args.length ();
  453.  
  454.   if (nargin == 0)
  455.     {
  456.       if (curr_function)
  457.     {
  458.       if (curr_function->takes_varargs ())
  459.         curr_function->octave_va_start ();
  460.       else
  461.         {
  462.           ::error ("va_start only valid within function taking variable");
  463.           ::error ("number of arguments");
  464.         }
  465.     }
  466.       else
  467.     ::error ("va_start only valid within function body");
  468.     }
  469.   else
  470.     print_usage ("va_start");
  471.  
  472.   return retval;
  473. }
  474.  
  475. DEFUN (vr_val, args, ,
  476.   "vr_val (X): append X to the list of optional return values for a\n\
  477. function that allows a variable number of return values")
  478. {
  479.   octave_value_list retval;
  480.  
  481.   int nargin = args.length ();
  482.  
  483.   if (nargin == 1)
  484.     {
  485.       if (curr_function)
  486.     {
  487.       if (curr_function->takes_var_return ())
  488.         curr_function->octave_vr_val (args(0));
  489.       else
  490.         {
  491.           ::error ("vr_val only valid within function declared to");
  492.           ::error ("produce a variable number of values");
  493.         }
  494.     }
  495.       else
  496.     ::error ("vr_val only valid within function body");
  497.     }
  498.   else
  499.     print_usage ("vr_val");
  500.  
  501.   return retval;
  502. }
  503.  
  504. static int
  505. define_all_return_values (void)
  506. {
  507.   Vdefine_all_return_values = check_preference ("define_all_return_values");
  508.  
  509.   return 0;
  510. }
  511.  
  512. static int
  513. return_last_computed_value (void)
  514. {
  515.   Vreturn_last_computed_value
  516.     = check_preference ("return_last_computed_value");
  517.  
  518.   return 0;
  519. }
  520.  
  521. static int
  522. silent_functions (void)
  523. {
  524.   Vsilent_functions = check_preference ("silent_functions");
  525.  
  526.   return 0;
  527. }
  528.  
  529. void
  530. symbols_of_pt_fcn (void)
  531. {
  532.   DEFVAR (default_return_value, Matrix (), 0, 0,
  533.     "the default for value for unitialized variables returned from\n\
  534. functions.  Only used if the variable initialize_return_values is\n\
  535. set to \"true\".");
  536.  
  537.   DEFVAR (define_all_return_values, 0.0, 0, define_all_return_values,
  538.     "control whether values returned from functions should have a\n\
  539. value even if one has not been explicitly assigned.  See also\n\
  540. default_return_value");
  541.  
  542.   DEFVAR (return_last_computed_value, 0.0, 0, return_last_computed_value,
  543.     "if a function does not return any values explicitly, return the\n\
  544.   last computed value");
  545.  
  546.   DEFVAR (silent_functions, 0.0, 0, silent_functions,
  547.     "suppress printing results in called functions");
  548. }
  549.  
  550. /*
  551. ;;; Local Variables: ***
  552. ;;; mode: C++ ***
  553. ;;; End: ***
  554. */
  555.